home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
MacFormat 1994 November
/
macformat-018.iso
/
Utility Spectacular
/
Developer
/
macgambit-20-compiler-src-p2
/
Interp⁄Comp (.scm)
/
target-m68000-2.scm
< prev
next >
Encoding:
Amiga
Atari
Commodore
DOS
FM Towns/JPY
Macintosh
Macintosh JP
NeXTSTEP
RISC OS/Acorn
Shift JIS
UTF-8
Wrap
Text File
|
1994-07-26
|
61.2 KB
|
1,823 lines
|
[
TEXT/gamI
]
;==============================================================================
; file: "target-m68000-2.scm"
;------------------------------------------------------------------------------
;
; Object file creation (for M680x0)
; ---------------------------------
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
; An object file is a collection of Scheme objects. The objects in the file
; are named by their position in the file. The first object in the file is
; object number 0, the second is object number 1, etc. Object number 0 is the
; startup procedure (it must be a procedure object). It will be called
; after the file has been loaded.
;
; The objects have the same layout as in memory (see below). However, a prefix
; appears in front of certain objects to give additional information about
; the given object. The prefix word 1 informs the loader that the following
; procedure object is a primitive procedure, and the prefix word 2 indicates
; a normal procedure. Pairs have a word prefix of 3.
;
; Object pointers contained in these objects also follow the same format
; as in memory with the following additions:
;
; 11111111111111100nnnnnnnnnnnn111 = pointer to object number 'n'
; 11111111111111101xxxxxxxxxxxx111 = pointer to interned symbol number 'x'
; 11111111111111110xxxxxxxxxxxx111 = pointer to primitive procedure number 'x'
;
; Finally, procedure objects have a special structure that is needed to
; describe the code part of the procedure. The code part of a procedure
; is made up of a sequence of blocks. Each block is preceded by a word tag 't'
; that specifies how to treat the block:
;
; t > 0000000000000000, quoted code (the following 't' words are loaded as is)
; t = 0000000000000000, padding (ignored)
; t = 1000000000000000, end of code (constant part of procedure follows)
; t = 1000000000000001, M68020 processor specific instruction marker
; t = 1000000000000010, M68881 processor specific instruction marker
; t = 1000000000000011, statistics reference (followed by statistics counters)
; t = 1001nnnnnnnnnnnn, local procedure ref (followed by offset to entry)
; t = 1010xxxxxxxxxxxx, global var ref to var number 'x'
; t = 1011xxxxxxxxxxxx, global var set to var number 'x'
; t = 1100xxxxxxxxxxxx, global var ref jump to var number 'x'
; t = 1101xxxxxxxxxxxx, primitive procedure ref to prim proc number 'x' (followed by offset to entry)
;
; In this description, 'xxxxxxxxxxxx' represents an index into a symbol table
; local to the object file. The special value of all 1's indicates that the
; tag is followed by a null terminated string to be added to the local symbol
; table (it is built as the file is loaded and is initially empty).
(define ofile-version-major 3)
(define ofile-version-minor 0)
(define prim-proc-prefix 1)
(define user-proc-prefix 2)
(define pair-prefix 3)
(define local-object-bits #x-1fff9) ; 11111111111111100000000000000111
(define symbol-object-bits #x-17ff9) ; 11111111111111101000000000000111
(define prim-proc-object-bits #x-0fff9) ; 11111111111111110000000000000111
(define padding-tag #x0000)
(define end-of-code-tag #x8000)
(define M68020-proc-code-tag #x8001)
(define M68881-proc-code-tag #x8002)
(define stat-tag #x8003)
(define local-proc-ref-tag #x9000)
(define global-var-ref-tag #xa000)
(define global-var-set-tag #xb000)
(define global-var-ref-jump-tag #xc000)
(define prim-proc-ref-tag #xd000)
(define index-mask #x0fff)
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
; Interface:
; ---------
(define (ofile.begin! filename add-obj)
(set! ofile-add-obj add-obj)
(set! ofile-syms (queue-empty))
(set! *ofile-port1* (open-output-file (string-append filename ".O")))
(if ofile-asm?
(begin
(set! *ofile-port2* (open-output-file (string-append filename ".asm")))
(set! *ofile-pos* 0)))
(ofile-line " .data")
(ofile-word ofile-version-major)
(ofile-word ofile-version-minor)
'())
(define (ofile.end!)
(ofile-line "")
(close-output-port *ofile-port1*)
(if ofile-asm?
(close-output-port *ofile-port2*))
'())
(define *ofile-port1* '())
(define *ofile-port2* '())
(define *ofile-pos* '())
(define ofile-nl char-newline)
(define ofile-tab char-tab)
(define ofile-asm? '())
(set! ofile-asm? '())
(define ofile-stats? '())
(set! ofile-stats? '())
(define ofile-add-obj '())
(set! ofile-add-obj '())
(define (ofile-word n)
(let ((n (modulo n #x10000)))
(if ofile-asm?
(let ()
(define (ofile-display x)
(display x *ofile-port2*)
(cond ((eq? x ofile-nl)
(set! *ofile-pos* 0))
((eq? x ofile-tab)
(set! *ofile-pos* (* (quotient (+ *ofile-pos* 8) 8) 8)))
(else
(set! *ofile-pos* (+ *ofile-pos* (string-length x))))))
(if (> *ofile-pos* 64) (ofile-display ofile-nl))
(if (= *ofile-pos* 0)
(ofile-display " .word")
(ofile-display ","))
(ofile-display ofile-tab)
(let ((s (make-string 6 #\0)))
(string-set! s 1 #\x)
(let loop ((i 5) (n n))
(if (> n 0)
(begin
(string-set! s i (string-ref "0123456789ABCDEF" (remainder n 16)))
(loop (- i 1) (quotient n 16)))))
(ofile-display s))))
(write-word n *ofile-port1*)))
(define (ofile-long x)
(ofile-word (upper-16bits x))
(ofile-word x))
(define (ofile-string s)
(let ((len (string-length s)))
(define (ref i) (if (>= i len) 0 (character-encoding (string-ref s i))))
(let loop ((i 0))
(if (< i len)
(begin
(ofile-word (+ (* (ref i) 256) (ref (+ i 1))))
(loop (+ i 2)))))
(if (= (remainder len 2) 0)
(ofile-word 0))))
(define (ofile-wsym tag name)
(let ((n (string-pos-in-list name (queue->list ofile-syms))))
(if n
(ofile-word (+ tag n))
(let ((m (length (queue->list ofile-syms))))
(queue-put! ofile-syms name)
(ofile-word (+ tag index-mask))
(ofile-string name)))))
(define (ofile-lsym tag name)
(let ((n (string-pos-in-list name (queue->list ofile-syms))))
(if n
(ofile-long (+ tag (* n 8)))
(let ((m (length (queue->list ofile-syms))))
(queue-put! ofile-syms name)
(ofile-long (+ tag (* index-mask 8)))
(ofile-string name)))))
(define (ofile-ref obj)
(let ((n (obj-encoding obj)))
(if n
(ofile-long n)
(if (symbol-object? obj)
(begin
(ofile-lsym symbol-object-bits (symbol->string obj)))
(let ((m (ofile-add-obj obj)))
(if m
(ofile-long (+ local-object-bits (* m 8)))
(begin
(ofile-lsym prim-proc-object-bits (proc-obj-name obj)))))))))
(define (ofile-prim-proc s)
(ofile-long prim-proc-prefix)
(ofile-wsym 0 s)
(ofile-comment (list "PRIMITIVE PROCEDURE: " s)))
(define (ofile-user-proc)
(ofile-long user-proc-prefix))
(define (ofile-line s)
(if ofile-asm?
(begin
(if (> *ofile-pos* 0) (newline *ofile-port2*))
(display s *ofile-port2*)
(newline *ofile-port2*)
(set! *ofile-pos* 0))))
(define (ofile-comment l)
(if ofile-asm?
(let ()
(define (tab n)
(let loop ()
(if (< *ofile-pos* n)
(begin
(display ofile-tab *ofile-port2*)
(set! *ofile-pos* (* (quotient (+ *ofile-pos* 8) 8) 8))
(loop)))))
(tab 32)
(display "|" *ofile-port2*)
(for-each (lambda (x) (display x *ofile-port2*)) l)
(newline *ofile-port2*)
(set! *ofile-pos* 0))))
(define (ofile-pvm-instr code)
(if ofile-asm?
(let ((pvm-instr (code-pvm-instr code))
(sn (code-slots-needed code)))
(if (> *ofile-pos* 0) (newline *ofile-port2*))
(display " |**** [" *ofile-port2*)
(display sn *ofile-port2*)
(display "] " *ofile-port2*)
(write-pvm-instr pvm-instr *ofile-port2*)
(newline *ofile-port2*)
(set! *ofile-pos* 0))))
(define (ofile-stat stat)
(define (->string x)
(cond ((string? x) x)
((symbol-object? x) (symbol->string x))
((number? x) (number->string x))
((false-object? x) "#f")
((eq? x #t) "#t")
((null? x) "()")
((pair? x)
(let loop ((l1 (cdr x)) (l2 (list (->string (car x)) "(")))
(cond ((pair? l1)
(loop (cdr l1)
(cons (->string (car l1)) (cons " " l2))))
((null? l1)
(apply string-append
(reverse (cons ")" l2))))
(else
(apply string-append
(reverse (cons ")" (cons (->string l1) (cons " . " l2)))))))))
(else
(compiler-internal-error
"ofile-stat, can't convert to string 'x'" x))))
(ofile-string (->string stat)))
(define (upper-16bits x)
(cond ((>= x 0) (quotient x #x10000))
((>= x (- #x10000)) -1)
(else (- (quotient (+ x #x10001) #x10000) 2))))
;-----------------------------------------------------------------------------
;
; Object representation:
; Objects are represented using 32 bit values. When more than 32 bits
; are needed to represent an object, the 32 bits are actually a pointer
; to the object in memory. All memory allocated objects start at an
; address that is a multiple of 8.
;
;
; 28 28
; * Fixnum (integer in the range -2 .. 2 -1):
;
; encoding = xxxxxxxxxxxxxxxxxxxxxxxxxxxxx000
; \------ integer value ------/
;
;
; * Special scalar values and characters:
;
; encoding = xxxxxxxxxxxxxxxxxxxxxxxxxxxxx111
; \-- encoding of value --/
;
; for example:
; 000000000000000000000xxxxxxxx111 = character
; 1xxxxxxxxxxxxxxxxxxxxxxxxxxxx111 = #f, #t, (), eof, ...
;
;
; * Pair (i.e. cons cell):
;
; xxxxxxxxxxxxxxxxxxxxxxxxxxxxx100
; _____________________
; xx...xx000 --> |_____________________| cdr | high
; |_____________________| car | memory
; <----- 32 bits -----> V
;
;
; * Future placeholder:
;
; encoding = xxxxxxxxxxxxxxxxxxxxxxxxxxxxx101
; _____________________
; xx...xx000 --> |_____________________| value | high
; |_____________________| lock | memory
; |_____________________| thunk V
; |_____________________| queue
; <----- 32 bits ----->
;
;
; * Subtyped objects:
;
; encoding = xxxxxxxxxxxxxxxxxxxxxxxxxxxxx011
; _____________________
; xx...xx000 --> |____length____|_type_| header | high
; |_____________________| \ | memory
; |_____________________| | data V
; |_____________________| /
; <----- 32 bits ----->
;
; 'Length' is a 24 bit field (in the upper part of the header word). The
; length must be positive (highest bit = 0) and indicates the length of
; the data part. The subtype is in the lower 8 bits of the header word
; and is encoded as subtype*8.
;
;
; * Procedures:
;
; encoding = xxxxxxxxxxxxxxxxxxxxxxxxxxxxx010
; _____________________
; xx...xx000 --> |__length__|__instr1__| \ | high
; |_____________________| | code | memory
; |_____________________| | V
; |_____________________| /
; |_____________________| \
; |_____________________| | data
; |_____________________| /
; <----- 32 bits ----->
;
; There are several types of procedure objects, each with it's own
; particularities: PROCEDUREs, SUBPROCEDUREs, CLOSUREs and RETURNs.
; Type tags
(define type-FIXNUM 0)
(define type-SPECIAL 7)
(define type-PAIR 4)
(define type-WEAK-PAIR 1)
(define type-PLACEHOLDER 5)
(define type-SUBTYPED 3)
(define type-PROCEDURE 2)
; Subtype tags
(define subtype-VECTOR 0)
(define subtype-SYMBOL 1)
(define subtype-PORT 2)
(define subtype-RATNUM 3)
(define subtype-CPXNUM 4)
(define subtype-CLOSURE 15)
(define subtype-STRING 16)
(define subtype-BIGNUM 17)
(define subtype-FLONUM 18)
; SPECIAL values:
(define data-FALSE (- #x2020203)) ; Data field for #f
(define data-NULL (- #x4040405)) ; Data field for ()
(define data-TRUE -2) ; Data field for #t
(define data-UNDEF -3) ; Data field for undefined object
(define data-UNASS -4) ; Data field for unassigned object
(define data-UNBOUND -5) ; Data field for unbound object
(define data-EOF -6) ; Data field for end-of-file object
(define data-max-fixnum #xfffffff) ; Max fixnum integer
(define data-min-fixnum (- #x10000000)) ; Min fixnum integer
; Utilities:
(define (make-encoding data type)
(+ (* data 8) type))
(define (obj-type obj)
(cond ((false-object? obj)
'SPECIAL)
((undef-object? obj)
'SPECIAL)
((symbol-object? obj)
'SUBTYPED)
((proc-obj? obj)
'PROCEDURE)
((eq? obj #t)
'SPECIAL)
((null? obj)
'SPECIAL)
((pair? obj)
'PAIR)
((number? obj)
(if (and (integer? obj) (exact? obj)
(>= obj data-min-fixnum) (<= obj data-max-fixnum))
'FIXNUM
'SUBTYPED))
((char? obj)
'SPECIAL)
(else
'SUBTYPED)))
(define (obj-subtype obj)
(cond ((symbol-object? obj)
'SYMBOL)
((number? obj)
(cond ((and (integer? obj) (exact? obj))
'BIGNUM)
((and (rational? obj) (exact? obj))
'RATNUM)
((and (zero? (imag-part obj)) (exact? (imag-part obj)))
'FLONUM)
(else
'CPXNUM)))
((vector? obj)
'VECTOR)
((string? obj)
'STRING)
(else
(compiler-internal-error
"obj-subtype, unknown object 'obj'" obj))))
(define (obj-type-tag obj)
(case (obj-type obj)
((FIXNUM) type-FIXNUM)
((SPECIAL) type-SPECIAL)
((PAIR) type-PAIR)
((SUBTYPED) type-SUBTYPED)
((PROCEDURE) type-PROCEDURE)
(else
(compiler-internal-error
"obj-type-tag, unknown object 'obj'" obj))))
(define (obj-encoding obj)
(case (obj-type obj)
((FIXNUM)
(make-encoding obj type-FIXNUM))
((SPECIAL)
(make-encoding
(cond ((false-object? obj) data-FALSE)
((undef-object? obj) data-UNDEF)
((eq? obj #t) data-TRUE)
((null? obj) data-NULL)
((char? obj) (character-encoding obj))
(else
(compiler-internal-error
"obj-encoding, unknown SPECIAL object 'obj'" obj)))
type-SPECIAL))
(else
#f)))
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(define bits-FALSE (make-encoding data-FALSE type-SPECIAL))
(define bits-NULL (make-encoding data-NULL type-SPECIAL))
(define bits-TRUE (make-encoding data-TRUE type-SPECIAL))
(define bits-UNASS (make-encoding data-UNASS type-SPECIAL))
(define bits-UNBOUND (make-encoding data-UNBOUND type-SPECIAL))
;------------------------------------------------------------------------------
;
; M680x0 assembler:
; ----------------
(define (asm.begin!)
(set! asm-code-queue (queue-empty))
(set! asm-const-queue (queue-empty))
'())
(define (asm.end! debug-info)
(asm-assemble! debug-info)
(set! asm-code-queue '())
(set! asm-const-queue '())
'())
(define asm-code-queue '())
(define asm-const-queue '())
(define (asm-word x)
(queue-put! asm-code-queue (modulo x #x10000)))
(define (asm-long x)
(asm-word (upper-16bits x))
(asm-word x))
(define (asm-label lbl label-descr)
(queue-put! asm-code-queue (cons 'LABEL (cons lbl label-descr))))
(define (asm-comment x)
(queue-put! asm-code-queue (cons 'COMMENT x)))
(define (asm-align n offset)
(queue-put! asm-code-queue (cons 'ALIGN (cons n offset))))
(define (asm-ref-glob glob)
(queue-put! asm-code-queue (cons 'REF-GLOB (symbol->string (glob-name glob)))))
(define (asm-set-glob glob)
(queue-put! asm-code-queue (cons 'SET-GLOB (symbol->string (glob-name glob)))))
(define (asm-ref-glob-jump glob)
(queue-put! asm-code-queue (cons 'REF-GLOB-JUMP (symbol->string (glob-name glob)))))
(define (asm-proc-ref num offset)
(queue-put! asm-code-queue
(cons 'PROC-REF (cons num offset))))
(define (asm-prim-ref proc offset)
(queue-put! asm-code-queue
(cons 'PRIM-REF (cons (proc-obj-name proc) offset))))
(define (asm-M68020-proc)
(queue-put! asm-code-queue '(M68020-PROC)))
(define (asm-M68881-proc)
(queue-put! asm-code-queue '(M68881-PROC)))
(define (asm-stat x)
(queue-put! asm-code-queue (cons 'STAT x)))
(define (asm-brel type lbl)
(queue-put! asm-code-queue (cons 'BRAB (cons type lbl))))
(define (asm-wrel lbl offs)
(queue-put! asm-code-queue (cons 'WREL (cons lbl offs))))
(define (asm-lrel lbl offs n)
(queue-put! asm-code-queue (cons 'LREL (cons lbl (cons offs n)))))
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(define (asm-assemble! debug-info)
(define header-offset 2) ; header length before code starts
(define ref-glob-len 2) ; length of code for a ref-glob
(define set-glob-len 10) ; length of code for a set-glob
(define ref-glob-jump-len 2) ; length of code for a ref-glob-jump
(define proc-ref-len 4) ; length of code for a proc-ref
(define prim-ref-len 4) ; length of code for a prim-ref
(define stat-len 4) ; length of code for a stat
(define (padding loc n offset)
(modulo (- offset loc) n))
(queue-put! asm-const-queue debug-info)
(asm-align 4 0)
(emit-label const-lbl)
(let ((code-list (queue->list asm-code-queue))
(const-list (queue->list asm-const-queue)))
(let* ((fix-list
(let loop ((l code-list) (len header-offset) (x '()))
(if (null? l)
(reverse x)
(let ((part (car l)) (rest (cdr l)))
(if (pair? part)
(case (car part)
((LABEL ALIGN BRAB) (loop rest 0 (cons (cons len part) x)))
((WREL) (loop rest (+ len 2) x))
((LREL) (loop rest (+ len 4) x))
((REF-GLOB) (loop rest (+ len ref-glob-len) x))
((SET-GLOB) (loop rest (+ len set-glob-len) x))
((REF-GLOB-JUMP) (loop rest (+ len ref-glob-jump-len) x))
((PROC-REF) (loop rest (+ len proc-ref-len) x))
((PRIM-REF) (loop rest (+ len prim-ref-len) x))
((STAT) (loop rest (+ len stat-len) x))
((COMMENT M68020-PROC M68881-PROC)
(loop rest len x))
(else
(compiler-internal-error
"asm-assemble!, unknown code list element" part)))
(loop rest (+ len 2) x))))))
(lbl-list
(let loop ((l fix-list) (x '()))
(if (null? l)
x
(let ((part (cdar l)) (rest (cdr l)))
(if (eq? (car part) 'LABEL)
(loop rest (cons (cons (cadr part) part) x))
(loop rest x)))))))
(define (replace-lbl-refs-by-pointer-to-label)
(let loop ((l code-list))
(if (not (null? l))
(let ((part (car l)) (rest (cdr l)))
(if (pair? part)
(case (car part)
((BRAB)
(set-cdr! (cdr part) (cdr (assq (cddr part) lbl-list))))
((WREL)
(set-car! (cdr part) (cdr (assq (cadr part) lbl-list))))
((LREL)
(set-car! (cdr part) (cdr (assq (cadr part) lbl-list))))))
(loop rest)))))
(define (assign-loc-to-labels)
(let loop ((l fix-list) (loc 0))
(if (not (null? l))
(let* ((first (car l))
(rest (cdr l))
(len (car first))
(cur-loc (+ loc len))
(part (cdr first)))
(case (car part)
((LABEL)
(if (cddr part)
(vector-set! (cddr part) 0
(quotient (- cur-loc header-offset) 8)))
(set-car! (cdr part) cur-loc)
(loop rest cur-loc))
((ALIGN)
(loop rest (+ cur-loc (padding cur-loc (cadr part) (cddr part)))))
((BRAB)
(loop rest (+ cur-loc 2)))
((BRAW)
(loop rest (+ cur-loc 4)))
(else
(compiler-internal-error
"assign-loc-to-labels, unknown code list element" part)))))))
(define (branch-tensioning-pass)
(assign-loc-to-labels)
(let loop ((changed? #f) (l fix-list) (loc 0))
(if (null? l)
(if changed? (branch-tensioning-pass)) ; do again if anything changed
(let* ((first (car l))
(rest (cdr l))
(len (car first))
(cur-loc (+ loc len))
(part (cdr first)))
(case (car part)
((LABEL)
(loop changed? rest cur-loc))
((ALIGN)
(loop changed? rest (+ cur-loc (padding cur-loc (cadr part) (cddr part)))))
((BRAB)
(let ((dist (- (cadr (cddr part)) (+ cur-loc 2))))
(if (or (< dist -128) (> dist 127) (= dist 0))
(begin
(set-car! part 'BRAW) ; BRAB -> BRAW if branch too far
(loop #t rest (+ cur-loc 2)))
(loop changed? rest (+ cur-loc 2)))))
((BRAW)
(loop changed? rest (+ cur-loc 4)))
(else
(compiler-internal-error
"branch-tensioning-pass, unknown code list element" part)))))))
(define (write-block start-loc end-loc start end)
(if (> end-loc start-loc)
(ofile-word (quotient (- end-loc start-loc) 2)))
(let loop ((loc start-loc) (l start))
(if (not (eq? l end))
(let ((part (car l)) (rest (cdr l)))
(if (pair? part)
(case (car part)
((LABEL)
(loop loc rest))
((ALIGN)
(let ((n (padding loc (cadr part) (cddr part))))
(let pad ((i 0))
(if (< i n)
(begin
(ofile-word 0)
(pad (+ i 2)))
(loop (+ loc n) rest)))))
((BRAB)
(let ((dist (- (cadr (cddr part)) (+ loc 2))))
(ofile-word (+ (cadr part) (modulo dist 256)))
(loop (+ loc 2) rest)))
((BRAW)
(let ((dist (- (cadr (cddr part)) (+ loc 2))))
(ofile-word (cadr part))
(ofile-word (modulo dist #x10000))
(loop (+ loc 4) rest)))
((WREL)
(let ((dist (+ (- (cadr (cadr part)) loc) (cddr part))))
(ofile-word (modulo dist #x10000))
(loop (+ loc 2) rest)))
((LREL)
(let ((dist (+ (- (cadr (cadr part)) loc) (caddr part))))
(ofile-long (+ (* dist #x10000) (cdddr part)))
(loop (+ loc 4) rest)))
((COMMENT)
(let ((x (cdr part)))
(if (pair? x)
(ofile-comment x)
(ofile-pvm-instr x))
(loop loc rest))))
(begin
(ofile-word part)
(loop (+ loc 2) rest)))))))
(define (write-code)
(let ((proc-len (+ (cadr (cdr (assq const-lbl lbl-list)))
(* (length const-list) 4))))
(if (>= proc-len #x8000)
(compiler-limitation-error
"procedure is too big (32K bytes limit per procedure)"))
(ofile-word (+ #x8000 proc-len)))
(let loop1 ((start code-list)
(start-loc header-offset))
(let loop2 ((end start)
(loc start-loc))
(if (null? end)
(write-block start-loc loc start end)
(let ((part (car end)) (rest (cdr end)))
(if (pair? part)
(case (car part)
((LABEL COMMENT) (loop2 rest loc))
((ALIGN) (loop2 rest (+ loc (padding loc (cadr part) (cddr part)))))
((BRAB WREL) (loop2 rest (+ loc 2)))
((BRAW) (loop2 rest (+ loc 4)))
((LREL) (loop2 rest (+ loc 4)))
(else
(write-block start-loc loc start end)
(case (car part)
((REF-GLOB)
(ofile-wsym global-var-ref-tag (cdr part))
(loop1 rest (+ loc ref-glob-len)))
((SET-GLOB)
(ofile-wsym global-var-set-tag (cdr part))
(loop1 rest (+ loc set-glob-len)))
((REF-GLOB-JUMP)
(ofile-wsym global-var-ref-jump-tag (cdr part))
(loop1 rest (+ loc ref-glob-jump-len)))
((PROC-REF)
(ofile-word (+ local-proc-ref-tag (cadr part)))
(ofile-word (cddr part))
(loop1 rest (+ loc proc-ref-len)))
((PRIM-REF)
(ofile-wsym prim-proc-ref-tag (cadr part))
(ofile-word (cddr part))
(loop1 rest (+ loc prim-ref-len)))
((M68020-PROC)
(ofile-word M68020-proc-code-tag)
(loop1 rest loc))
((M68881-PROC)
(ofile-word M68881-proc-code-tag)
(loop1 rest loc))
((STAT)
(ofile-word stat-tag)
(ofile-stat (cdr part))
(loop1 rest (+ loc stat-len))))))
(loop2 rest (+ loc 2)))))))
(ofile-word end-of-code-tag)
(for-each ofile-ref const-list)
(ofile-long (obj-encoding (+ (length const-list) 1))))
(replace-lbl-refs-by-pointer-to-label)
(branch-tensioning-pass)
(write-code))))
(define const-lbl 0)
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
; M68000 operands:
; All operands are represented with integers or symbols and can be tested for
; equality using 'eqv?'. The representation is similar to the actual bit
; sequence used by the hardware. This makes for an efficient
; 'opnd->mode/reg' procedure.
(define (identical-opnd68? opnd1 opnd2) (eqv? opnd1 opnd2))
(define (reg68? x) (or (dreg? x) (areg? x)))
; -- data register
(define (make-dreg num) num)
(define (dreg? x) (and (integer? x) (>= x 0) (< x 8)))
(define (dreg-num x) x)
; -- address register
(define (make-areg num) (+ num 8))
(define (areg? x) (and (integer? x) (>= x 8) (< x 16)))
(define (areg-num x) (- x 8))
; -- address register indirect
(define (make-ind areg) (+ areg 8))
(define (ind? x) (and (integer? x) (>= x 16) (< x 24)))
(define (ind-areg x) (- x 8))
; -- address register indirect with postincrement
(define (make-pinc areg) (+ areg 16))
(define (pinc? x) (and (integer? x) (>= x 24) (< x 32)))
(define (pinc-areg x) (- x 16))
; -- address register indirect with predecrement
(define (make-pdec areg) (+ areg 24))
(define (pdec? x) (and (integer? x) (>= x 32) (< x 40)))
(define (pdec-areg x) (- x 24))
; -- address register indirect with displacement
(define (make-disp areg offset) (+ (+ areg 32) (* (modulo offset #x10000) 8)))
(define (disp? x) (and (integer? x) (>= x 40) (< x 524328)))
(define (disp-areg x) (+ (remainder x 8) 8))
(define (disp-offset x) (- (modulo (+ (quotient (- x 40) 8) #x8000) #x10000) #x8000))
(define (make-disp* areg offset) ; smarter version of 'make-disp'
(if (= offset 0) (make-ind areg) (make-disp areg offset)))
(define (disp*? x) (or (ind? x) (disp? x)))
(define (disp*-areg x) (if (ind? x) (ind-areg x) (disp-areg x)))
(define (disp*-offset x) (if (ind? x) 0 (disp-offset x)))
; -- address register indirect with index
(define (make-inx areg ireg offset) (+ (+ areg 524320) (* ireg 8) (* (modulo offset #x100) 128)))
(define (inx? x) (and (integer? x) (>= x 524328) (< x 557096)))
(define (inx-areg x) (+ (remainder (- x 524328) 8) 8))
(define (inx-ireg x) (quotient (remainder (- x 524328) 128) 8))
(define (inx-offset x) (- (modulo (+ (quotient (- x 524328) 128) #x80) #x100) #x80))
; -- M68881 floating point coprocessor register
(define (make-freg num) (+ 557096 num))
(define (freg? x) (and (integer? x) (>= x 557096) (< x 557104)))
(define (freg-num x) (- x 557096))
; -- pc relative
(define (make-pcr lbl offset) (+ 557104 (+ (modulo offset #x10000) (* lbl #x10000))))
(define (pcr? x) (and (integer? x) (>= x 557104)))
(define (pcr-lbl x) (quotient (- x 557104) #x10000))
(define (pcr-offset x) (- (modulo (- x 524336) #x10000) #x8000))
; -- immediate
(define (make-imm val) (if (< val 0) (* val 2) (- -1 (* val 2))))
(define (imm? x) (and (integer? x) (< x 0)))
(define (imm-val x) (if (even? x) (quotient x 2) (- (quotient x 2))))
; -- global variable
(define (make-glob name) name)
(define (glob? x) (symbol? x))
(define (glob-name x) x)
; -- 'frame base relative' stack operand
(define (make-frame-base-rel slot) (make-disp sp-reg slot))
(define (frame-base-rel? x) (and (disp? x) (identical-opnd68? sp-reg (disp-areg x))))
(define (frame-base-rel-slot x) (disp-offset x))
; -- register list
(define (make-reg-list regs) regs)
(define (reg-list? x) (or (pair? x) (null? x)))
(define (reg-list-regs x) x)
; Common operands:
(define first-dtemp 0) ; first data register temporary
(define pvm-reg1 1) ; first general PVM register
(define intr-timer-reg (make-dreg 5)) ; countdown timer for interrupts
(define null-reg (make-dreg 6)) ; register that contains ()
(define placeholder-reg (make-dreg 6)) ; future mask register
(define false-reg (make-dreg 7)) ; register that contains #f
(define pair-reg (make-dreg 7)) ; pair mask register
(define pvm-reg0 0) ; return address register
(define first-atemp 1) ; first address register temporary
(define heap-reg (make-areg 3)) ; heaplet allocation register
(define ltq-tail-reg (make-areg 4)) ; pointer to tail of lazy task queue
(define pstate-reg (make-areg 5)) ; processor state pointer register
(define table-reg (make-areg 6)) ; global variable and code pointer register
(define sp-reg (make-areg 7)) ; stack pointer register
(define pdec-sp (make-pdec sp-reg)) ; push
(define pinc-sp (make-pinc sp-reg)) ; pop
(define dtemp1 (make-dreg first-dtemp))
(define atemp1 (make-areg first-atemp))
(define atemp2 (make-areg (+ first-atemp 1)))
(define ftemp1 (make-freg 0))
(define ftemp2 (make-freg 1))
(define arg-count-reg dtemp1)
(define (trap-offset n)
(+ #x8000 (* (- n 32) 8)))
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
; M68000 instructions:
(define (emit-move.l opnd1 opnd2)
(let ((src (opnd->mode/reg opnd1))
(dst (opnd->reg/mode opnd2)))
(asm-word (+ #x2000 (+ dst src)))
(opnd-ext-rd-long opnd1)
(opnd-ext-wr-long opnd2)
(if ofile-asm?
(emit-asm "movl" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2)))))
(define (emit-move.w opnd1 opnd2)
(let ((src (opnd->mode/reg opnd1))
(dst (opnd->reg/mode opnd2)))
(asm-word (+ #x3000 (+ dst src)))
(opnd-ext-rd-word opnd1)
(opnd-ext-wr-word opnd2)
(if ofile-asm?
(emit-asm "movw" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2)))))
(define (emit-move.b opnd1 opnd2)
(let ((src (opnd->mode/reg opnd1))
(dst (opnd->reg/mode opnd2)))
(asm-word (+ #x1000 (+ dst src)))
(opnd-ext-rd-word opnd1)
(opnd-ext-wr-word opnd2)
(if ofile-asm?
(emit-asm "movb" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2)))))
(define (emit-moveq n opnd)
(asm-word (+ #x7000 (+ (* (dreg-num opnd) 512) (modulo n 256))))
(if ofile-asm?
(emit-asm "moveq" ofile-tab "#" n "," (opnd-str opnd))))
(define (emit-movem.l opnd1 opnd2)
(define (reg-mask reg-list flip-bits?)
(let loop ((i 15) (bit #x8000) (mask 0))
(if (>= i 0)
(loop (- i 1)
(quotient bit 2)
(if (memq i reg-list)
(+ mask (if flip-bits? (quotient #x8000 bit) bit))
mask))
mask)))
(define (movem op reg-list opnd)
(asm-word (+ op (opnd->mode/reg opnd)))
(asm-word (reg-mask reg-list (pdec? opnd))))
(if (reg-list? opnd1)
(begin
(movem #x48c0 opnd1 opnd2)
(opnd-ext-wr-long opnd2))
(begin
(movem #x4cc0 opnd2 opnd1)
(opnd-ext-rd-long opnd1)))
(if ofile-asm?
(emit-asm "moveml" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))
(define (emit-exg opnd1 opnd2)
(define (exg r1 r2)
(let ((mode (if (dreg? r2) #xc140 (if (dreg? r1) #xc188 #xc148)))
(num1 (if (dreg? r1) (dreg-num r1) (areg-num r1)))
(num2 (if (dreg? r2) (dreg-num r2) (areg-num r2))))
(asm-word (+ mode (+ (* num1 512) num2)))))
(if (dreg? opnd2) (exg opnd2 opnd1) (exg opnd1 opnd2))
(if ofile-asm?
(emit-asm "exg" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))
(define (emit-eor.l opnd1 opnd2)
(cond ((imm? opnd1)
(asm-word (+ #x0a80 (opnd->mode/reg opnd2)))
(opnd-ext-rd-long opnd1)
(opnd-ext-wr-long opnd2))
(else
(asm-word (+ #xb180 (+ (* (dreg-num opnd1) 512) (opnd->mode/reg opnd2))))
(opnd-ext-wr-long opnd2)))
(if ofile-asm?
(emit-asm "eorl" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))
(define (emit-and.l opnd1 opnd2)
(cond ((imm? opnd1)
(asm-word (+ #x0280 (opnd->mode/reg opnd2)))
(opnd-ext-rd-long opnd1)
(opnd-ext-wr-long opnd2))
(else
(let ((mode (if (dreg? opnd2) #xc080 #xc180))
(reg (if (dreg? opnd2) (dreg-num opnd2) (dreg-num opnd1)))
(other (if (dreg? opnd2) opnd1 opnd2)))
(asm-word (+ mode (+ (* reg 512) (opnd->mode/reg other))))
(if (dreg? opnd2)
(opnd-ext-rd-long other)
(opnd-ext-wr-long other)))))
(if ofile-asm?
(emit-asm "andl" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))
(define (emit-and.w opnd1 opnd2)
(cond ((imm? opnd1)
(asm-word (+ #x0240 (opnd->mode/reg opnd2)))
(opnd-ext-rd-word opnd1)
(opnd-ext-wr-word opnd2))
(else
(let ((mode (if (dreg? opnd2) #xc040 #xc140))
(reg (if (dreg? opnd2) (dreg-num opnd2) (dreg-num opnd1)))
(other (if (dreg? opnd2) opnd1 opnd2)))
(asm-word (+ mode (+ (* reg 512) (opnd->mode/reg other))))
(if (dreg? opnd2)
(opnd-ext-rd-word other)
(opnd-ext-wr-word other)))))
(if ofile-asm?
(emit-asm "andw" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))
(define (emit-or.l opnd1 opnd2)
(cond ((imm? opnd1)
(asm-word (+ #x0080 (opnd->mode/reg opnd2)))
(opnd-ext-rd-long opnd1)
(opnd-ext-wr-long opnd2))
(else
(let ((mode (if (dreg? opnd2) #x8080 #x8180))
(reg (if (dreg? opnd2) (dreg-num opnd2) (dreg-num opnd1)))
(other (if (dreg? opnd2) opnd1 opnd2)))
(asm-word (+ mode (+ (* reg 512) (opnd->mode/reg other))))
(if (dreg? opnd2)
(opnd-ext-rd-long other)
(opnd-ext-wr-long other)))))
(if ofile-asm?
(emit-asm "orl" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))
(define (emit-addq.l n opnd)
(let ((m (if (= n 8) 0 n)))
(asm-word (+ #x5080 (* m 512) (opnd->mode/reg opnd)))
(opnd-ext-wr-long opnd)
(if ofile-asm?
(emit-asm "addql" ofile-tab "#" n "," (opnd-str opnd)))))
(define (emit-addq.w n opnd)
(let ((m (if (= n 8) 0 n)))
(asm-word (+ #x5040 (* m 512) (opnd->mode/reg opnd)))
(opnd-ext-wr-word opnd)
(if ofile-asm?
(emit-asm "addqw" ofile-tab "#" n "," (opnd-str opnd)))))
(define (emit-add.l opnd1 opnd2)
(cond ((areg? opnd2)
(asm-word (+ #xd1c0 (+ (* (areg-num opnd2) 512) (opnd->mode/reg opnd1))))
(opnd-ext-rd-long opnd1))
((imm? opnd1)
(asm-word (+ #x0680 (opnd->mode/reg opnd2)))
(opnd-ext-rd-long opnd1)
(opnd-ext-wr-long opnd2))
(else
(let ((mode (if (dreg? opnd2) #xd080 #xd180))
(reg (if (dreg? opnd2) (dreg-num opnd2) (dreg-num opnd1)))
(other (if (dreg? opnd2) opnd1 opnd2)))
(asm-word (+ mode (+ (* reg 512) (opnd->mode/reg other))))
(if (dreg? opnd2)
(opnd-ext-rd-long other)
(opnd-ext-wr-long other)))))
(if ofile-asm?
(emit-asm "addl" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))
(define (emit-add.w opnd1 opnd2)
(cond ((areg? opnd2)
(asm-word (+ #xd0c0 (+ (* (areg-num opnd2) 512) (opnd->mode/reg opnd1))))
(opnd-ext-rd-word opnd1))
((imm? opnd1)
(asm-word (+ #x0640 (opnd->mode/reg opnd2)))
(opnd-ext-rd-word opnd1)
(opnd-ext-rd-word opnd2))
(else
(let ((mode (if (dreg? opnd2) #xd040 #xd140))
(reg (if (dreg? opnd2) (dreg-num opnd2) (dreg-num opnd1)))
(other (if (dreg? opnd2) opnd1 opnd2)))
(asm-word (+ mode (+ (* reg 512) (opnd->mode/reg other))))
(if (dreg? opnd2)
(opnd-ext-rd-word other)
(opnd-ext-wr-word other)))))
(if ofile-asm?
(emit-asm "addw" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))
(define (emit-addx.w opnd1 opnd2)
(if (dreg? opnd1)
(asm-word (+ #xd140 (+ (* (dreg-num opnd2) 512) (dreg-num opnd1))))
(asm-word (+ #xd148 (+ (* (areg-num (pdec-areg opnd2)) 512) (areg-num (pdec-areg opnd1))))))
(if ofile-asm?
(emit-asm "addxw" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))
(define (emit-subq.l n opnd)
(let ((m (if (= n 8) 0 n)))
(asm-word (+ #x5180 (* m 512) (opnd->mode/reg opnd)))
(opnd-ext-wr-long opnd)
(if ofile-asm?
(emit-asm "subql" ofile-tab "#" n "," (opnd-str opnd)))))
(define (emit-subq.w n opnd)
(let ((m (if (= n 8) 0 n)))
(asm-word (+ #x5140 (* m 512) (opnd->mode/reg opnd)))
(opnd-ext-wr-word opnd)
(if ofile-asm?
(emit-asm "subqw" ofile-tab "#" n "," (opnd-str opnd)))))
(define (emit-sub.l opnd1 opnd2)
(cond ((areg? opnd2)
(asm-word (+ #x91c0 (+ (* (areg-num opnd2) 512) (opnd->mode/reg opnd1))))
(opnd-ext-rd-long opnd1))
((imm? opnd1)
(asm-word (+ #x0480 (opnd->mode/reg opnd2)))
(opnd-ext-rd-long opnd1)
(opnd-ext-rd-long opnd2))
(else
(let ((mode (if (dreg? opnd2) #x9080 #x9180))
(reg (if (dreg? opnd2) (dreg-num opnd2) (dreg-num opnd1)))
(other (if (dreg? opnd2) opnd1 opnd2)))
(asm-word (+ mode (+ (* reg 512) (opnd->mode/reg other))))
(if (dreg? opnd2)
(opnd-ext-rd-long other)
(opnd-ext-wr-long other)))))
(if ofile-asm?
(emit-asm "subl" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))
(define (emit-asl.l opnd1 opnd2)
(if (dreg? opnd1)
(asm-word (+ #xe1a0 (+ (* (dreg-num opnd1) 512) (dreg-num opnd2))))
(let ((n (imm-val opnd1)))
(asm-word (+ #xe180 (+ (* (if (= n 8) 0 n) 512) (dreg-num opnd2))))))
(if ofile-asm?
(emit-asm "asll" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))
(define (emit-asl.w opnd1 opnd2)
(if (dreg? opnd1)
(asm-word (+ #xe160 (+ (* (dreg-num opnd1) 512) (dreg-num opnd2))))
(let ((n (imm-val opnd1)))
(asm-word (+ #xe140 (+ (* (if (= n 8) 0 n) 512) (dreg-num opnd2))))))
(if ofile-asm?
(emit-asm "aslw" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))
(define (emit-asr.l opnd1 opnd2)
(if (dreg? opnd1)
(asm-word (+ #xe0a0 (+ (* (dreg-num opnd1) 512) (dreg-num opnd2))))
(let ((n (imm-val opnd1)))
(asm-word (+ #xe080 (+ (* (if (= n 8) 0 n) 512) (dreg-num opnd2))))))
(if ofile-asm?
(emit-asm "asrl" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))
(define (emit-asr.w opnd1 opnd2)
(if (dreg? opnd1)
(asm-word (+ #xe060 (+ (* (dreg-num opnd1) 512) (dreg-num opnd2))))
(let ((n (imm-val opnd1)))
(asm-word (+ #xe040 (+ (* (if (= n 8) 0 n) 512) (dreg-num opnd2))))))
(if ofile-asm?
(emit-asm "asrw" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))
(define (emit-lsl.l opnd1 opnd2)
(if (dreg? opnd1)
(asm-word (+ #xe1a8 (+ (* (dreg-num opnd1) 512) (dreg-num opnd2))))
(let ((n (imm-val opnd1)))
(asm-word (+ #xe188 (+ (* (if (= n 8) 0 n) 512) (dreg-num opnd2))))))
(if ofile-asm?
(emit-asm "lsll" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))
(define (emit-lsr.l opnd1 opnd2)
(if (dreg? opnd1)
(asm-word (+ #xe0a8 (+ (* (dreg-num opnd1) 512) (dreg-num opnd2))))
(let ((n (imm-val opnd1)))
(asm-word (+ #xe088 (+ (* (if (= n 8) 0 n) 512) (dreg-num opnd2))))))
(if ofile-asm?
(emit-asm "lsrl" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))
(define (emit-lsr.w opnd1 opnd2)
(if (dreg? opnd1)
(asm-word (+ #xe068 (+ (* (dreg-num opnd1) 512) (dreg-num opnd2))))
(let ((n (imm-val opnd1)))
(asm-word (+ #xe048 (+ (* (if (= n 8) 0 n) 512) (dreg-num opnd2))))))
(if ofile-asm?
(emit-asm "lsrw" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))
(define (emit-clr.l opnd)
(asm-word (+ #x4280 (opnd->mode/reg opnd)))
(opnd-ext-wr-long opnd)
(if ofile-asm?
(emit-asm "clrl" ofile-tab (opnd-str opnd))))
(define (emit-neg.l opnd)
(asm-word (+ #x4480 (opnd->mode/reg opnd)))
(opnd-ext-wr-long opnd)
(if ofile-asm?
(emit-asm "negl" ofile-tab (opnd-str opnd))))
(define (emit-not.l opnd)
(asm-word (+ #x4680 (opnd->mode/reg opnd)))
(opnd-ext-wr-long opnd)
(if ofile-asm?
(emit-asm "notl" ofile-tab (opnd-str opnd))))
(define (emit-ext.l opnd)
(asm-word (+ #x48c0 (dreg-num opnd)))
(if ofile-asm?
(emit-asm "extl" ofile-tab (opnd-str opnd))))
(define (emit-ext.w opnd)
(asm-word (+ #x4880 (dreg-num opnd)))
(if ofile-asm?
(emit-asm "extw" ofile-tab (opnd-str opnd))))
(define (emit-swap opnd)
(asm-word (+ #x4840 (dreg-num opnd)))
(if ofile-asm?
(emit-asm "swap" ofile-tab (opnd-str opnd))))
(define (emit-cmp.l opnd1 opnd2)
(cond ((areg? opnd2)
(asm-word (+ #xb1c0 (+ (* (areg-num opnd2) 512) (opnd->mode/reg opnd1))))
(opnd-ext-rd-long opnd1))
((imm? opnd1)
(asm-word (+ #x0c80 (opnd->mode/reg opnd2)))
(opnd-ext-rd-long opnd1)
(opnd-ext-rd-long opnd2))
(else
(asm-word (+ #xb080 (+ (* (dreg-num opnd2) 512) (opnd->mode/reg opnd1))))
(opnd-ext-rd-long opnd1)))
(if ofile-asm?
(emit-asm "cmpl" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))
(define (emit-cmp.w opnd1 opnd2)
(cond ((areg? opnd2)
(asm-word (+ #xb0c0 (+ (* (areg-num opnd2) 512) (opnd->mode/reg opnd1))))
(opnd-ext-rd-word opnd1))
((imm? opnd1)
(asm-word (+ #x0c40 (opnd->mode/reg opnd2)))
(opnd-ext-rd-word opnd1)
(opnd-ext-rd-word opnd2))
(else
(asm-word (+ #xb040 (+ (* (dreg-num opnd2) 512) (opnd->mode/reg opnd1))))
(opnd-ext-rd-word opnd1)))
(if ofile-asm?
(emit-asm "cmpw" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))
(define (emit-cmp.b opnd1 opnd2)
(cond ((imm? opnd1)
(asm-word (+ #x0c00 (opnd->mode/reg opnd2)))
(opnd-ext-rd-word opnd1)
(opnd-ext-rd-word opnd2))
(else
(asm-word (+ #xb000 (+ (* (dreg-num opnd2) 512) (opnd->mode/reg opnd1))))
(opnd-ext-rd-word opnd1)))
(if ofile-asm?
(emit-asm "cmpb" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))
(define (emit-tst.l opnd)
(asm-word (+ #x4a80 (opnd->mode/reg opnd)))
(opnd-ext-rd-long opnd)
(if ofile-asm?
(emit-asm "tstl" ofile-tab (opnd-str opnd))))
(define (emit-tst.w opnd)
(asm-word (+ #x4a40 (opnd->mode/reg opnd)))
(opnd-ext-rd-word opnd)
(if ofile-asm?
(emit-asm "tstw" ofile-tab (opnd-str opnd))))
(define (emit-lea opnd areg)
(asm-word (+ #x41c0 (+ (* (areg-num areg) 512) (opnd->mode/reg opnd))))
(opnd-ext-rd-long opnd)
(if ofile-asm?
(emit-asm "lea" ofile-tab (opnd-str opnd) "," (opnd-str areg))))
(define (emit-unlk areg)
(asm-word (+ #x4e58 (areg-num areg)))
(if ofile-asm?
(emit-asm "unlk" ofile-tab (opnd-str areg))))
(define (emit-tas opnd)
(asm-word (+ #x4ac0 (opnd->mode/reg opnd)))
(opnd-ext-wr-long opnd)
(if ofile-asm?
(emit-asm "tas" ofile-tab (opnd-str opnd))))
(define (emit-lea* n areg)
(asm-word (+ #x41f8 (* (areg-num areg) 512)))
(asm-word n)
(if ofile-asm?
(emit-asm "lea" ofile-tab n "," (opnd-str areg))))
(define (emit-move-proc num opnd)
(let ((dst (opnd->reg/mode opnd)))
(asm-word (+ #x2000 (+ dst 60)))
(asm-proc-ref num 0)
(opnd-ext-wr-long opnd)
(if ofile-asm?
(emit-asm "MOVE_PROC(" num "," (opnd-str opnd) ")"))))
(define (emit-move-prim val opnd)
(let ((dst (opnd->reg/mode opnd)))
(asm-word (+ #x2000 (+ dst 60)))
(asm-prim-ref val 0)
(opnd-ext-wr-long opnd)
(if ofile-asm?
(emit-asm "MOVE_PRIM(" (proc-obj-name val) "," (opnd-str opnd) ")"))))
(define (emit-pea opnd)
(asm-word (+ #x4840 (opnd->mode/reg opnd)))
(opnd-ext-rd-long opnd)
(if ofile-asm?
(emit-asm "pea" ofile-tab (opnd-str opnd))))
(define (emit-pea* n)
(asm-word #x4878)
(asm-word n)
(if ofile-asm?
(emit-asm "pea" ofile-tab n)))
(define (emit-btst opnd1 opnd2)
(asm-word (+ #x0100 (+ (* (dreg-num opnd1) 512) (opnd->mode/reg opnd2))))
(opnd-ext-rd-word opnd2)
(if ofile-asm?
(emit-asm "btst" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))
(define (emit-bra lbl)
(asm-brel #x6000 lbl)
(if ofile-asm?
(emit-asm "bra" ofile-tab "L" lbl)))
(define (emit-bcc lbl)
(asm-brel #x6400 lbl)
(if ofile-asm?
(emit-asm "bcc" ofile-tab "L" lbl)))
(define (emit-bcs lbl)
(asm-brel #x6500 lbl)
(if ofile-asm?
(emit-asm "bcs" ofile-tab "L" lbl)))
(define (emit-bhi lbl)
(asm-brel #x6200 lbl)
(if ofile-asm?
(emit-asm "bhi" ofile-tab "L" lbl)))
(define (emit-bls lbl)
(asm-brel #x6300 lbl)
(if ofile-asm?
(emit-asm "bls" ofile-tab "L" lbl)))
(define (emit-bmi lbl)
(asm-brel #x6b00 lbl)
(if ofile-asm?
(emit-asm "bmi" ofile-tab "L" lbl)))
(define (emit-bpl lbl)
(asm-brel #x6a00 lbl)
(if ofile-asm?
(emit-asm "bpl" ofile-tab "L" lbl)))
(define (emit-beq lbl)
(asm-brel #x6700 lbl)
(if ofile-asm?
(emit-asm "beq" ofile-tab "L" lbl)))
(define (emit-bne lbl)
(asm-brel #x6600 lbl)
(if ofile-asm?
(emit-asm "bne" ofile-tab "L" lbl)))
(define (emit-blt lbl)
(asm-brel #x6d00 lbl)
(if ofile-asm?
(emit-asm "blt" ofile-tab "L" lbl)))
(define (emit-bgt lbl)
(asm-brel #x6e00 lbl)
(if ofile-asm?
(emit-asm "bgt" ofile-tab "L" lbl)))
(define (emit-ble lbl)
(asm-brel #x6f00 lbl)
(if ofile-asm?
(emit-asm "ble" ofile-tab "L" lbl)))
(define (emit-bge lbl)
(asm-brel #x6c00 lbl)
(if ofile-asm?
(emit-asm "bge" ofile-tab "L" lbl)))
(define (emit-dbra dreg lbl)
(asm-word (+ #x51c8 dreg))
(asm-wrel lbl 0)
(if ofile-asm?
(emit-asm "dbra" ofile-tab (opnd-str dreg) ",L" lbl)))
(define (emit-trap num)
(asm-word (+ #x4e40 num))
(if ofile-asm?
(emit-asm "trap" ofile-tab "#" num)))
(define (emit-trap1 num args)
(asm-word (+ #x4ea8 (areg-num table-reg)))
(asm-word (trap-offset num))
(let loop ((args args))
(if (not (null? args))
(begin
(asm-word (car args))
(loop (cdr args)))))
(if ofile-asm?
(let ()
(define (words l)
(if (null? l) (list ")") (cons "," (cons (car l) (words (cdr l))))))
(apply emit-asm (cons "TRAP1(" (cons num (words args)))))))
(define (emit-trap2 num args)
(asm-word (+ #x4ea8 (areg-num table-reg)))
(asm-word (trap-offset num))
(asm-align 8 (modulo (- 4 (* (length args) 2)) 8))
(let loop ((args args))
(if (not (null? args))
(begin
(asm-word (car args))
(loop (cdr args)))))
(if ofile-asm?
(let ()
(define (words l)
(if (null? l) (list ")") (cons "," (cons (car l) (words (cdr l))))))
(apply emit-asm (cons "TRAP2(" (cons num (words args)))))))
(define (emit-trap3 num)
(asm-word (+ #x4ee8 (areg-num table-reg)))
(asm-word (trap-offset num))
(if ofile-asm?
(emit-asm "TRAP3(" num ")")))
(define (emit-rts)
(asm-word #x4e75)
(if ofile-asm?
(emit-asm "rts")))
(define (emit-nop)
(asm-word #x4e71)
(if ofile-asm?
(emit-asm "nop")))
(define (emit-jmp opnd)
(asm-word (+ #x4ec0 (opnd->mode/reg opnd)))
(opnd-ext-rd-long opnd)
(if ofile-asm?
(emit-asm "jmp" ofile-tab (opnd-str opnd))))
(define (emit-jmp-glob glob)
(asm-word #x226e)
(asm-ref-glob-jump glob)
(asm-word #x4ed1)
(if ofile-asm?
(emit-asm "JMP_GLOB(" (glob-name glob) ")")))
(define (emit-jmp-proc num offset)
(asm-word #x4ef9)
(asm-proc-ref num offset)
(if ofile-asm?
(emit-asm "JMP_PROC(" num "," offset ")")))
(define (emit-jmp-prim val offset)
(asm-word #x4ef9)
(asm-prim-ref val offset)
(if ofile-asm?
(emit-asm "JMP_PRIM(" (proc-obj-name val) "," offset ")")))
(define (emit-jsr opnd)
(asm-word (+ #x4e80 (opnd->mode/reg opnd)))
(opnd-ext-rd-long opnd)
(if ofile-asm?
(emit-asm "jsr" ofile-tab (opnd-str opnd))))
(define (emit-word n)
(asm-word n)
(if ofile-asm?
(emit-asm ".word" ofile-tab n)))
(define (emit-label lbl)
(asm-label lbl #f)
(if ofile-asm?
(emit-asm* "L" lbl ":")))
(define (emit-label-subproc lbl parent-lbl label-descr)
(asm-align 8 0)
(asm-wrel parent-lbl (- #x8000 type-PROCEDURE))
(asm-label lbl label-descr)
(if ofile-asm?
(begin
(emit-asm "SUBPROC(L" parent-lbl ")")
(emit-asm* "L" lbl ":"))))
(define (emit-label-return lbl parent-lbl fs link label-descr)
(asm-align 8 4)
(asm-word (* fs 4))
(asm-word (* (- fs link) 4))
(asm-wrel parent-lbl (- #x8000 type-PROCEDURE))
(asm-label lbl label-descr)
(if ofile-asm?
(begin
(emit-asm "RETURN(L" parent-lbl "," fs "," link ")")
(emit-asm* "L" lbl ":"))))
(define (emit-label-return-lazy lbl parent-lbl fs link label-descr)
(asm-align 8 4)
(asm-word (+ #x8000 (* fs 4)))
(asm-word (* (- fs link) 4))
(asm-wrel parent-lbl (- #x8000 type-PROCEDURE))
(asm-label lbl label-descr)
(if ofile-asm?
(begin
(emit-asm "RETURN_LAZY(L" parent-lbl "," fs "," link ")")
(emit-asm* "L" lbl ":"))))
(define (emit-lbl-ptr lbl)
(asm-wrel lbl 0)
(if ofile-asm?
(emit-asm "LBL_PTR(L" lbl ")")))
(define (emit-set-glob glob)
(asm-set-glob glob)
(if ofile-asm?
(emit-asm "SET_GLOB(" (glob-name glob) ")")))
(define (emit-const obj)
(let ((n (pos-in-list obj (queue->list asm-const-queue))))
(if n
(make-pcr const-lbl (* n 4))
(let ((m (length (queue->list asm-const-queue))))
(queue-put! asm-const-queue obj)
(make-pcr const-lbl (* m 4))))))
(define (emit-stat stat)
(asm-word #x52b9)
(asm-stat stat)
(if ofile-asm?
(emit-asm "STAT(" stat ")")))
(define (emit-asm . l)
(asm-comment (cons ofile-tab l)))
(define (emit-asm* . l)
(asm-comment l))
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
; M68020 instructions:
(define (emit-muls.l opnd1 opnd2)
(asm-M68020-proc)
(asm-word (+ #x4c00 (opnd->mode/reg opnd1)))
(asm-word (+ #x0800 (* (dreg-num opnd2) 4096)))
(opnd-ext-rd-long opnd1)
(if ofile-asm?
(emit-asm "mulsl" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))
(define (emit-divsl.l opnd1 opnd2 opnd3)
(asm-M68020-proc)
(asm-word (+ #x4c40 (opnd->mode/reg opnd1)))
(asm-word (+ #x0800 (* (dreg-num opnd3) 4096) (dreg-num opnd2)))
(opnd-ext-rd-long opnd1)
(if ofile-asm?
(emit-asm "divsll" ofile-tab (opnd-str opnd1) ","
(opnd-str opnd2) ":" (opnd-str opnd3))))
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
; M68881 instructions:
(define (emit-fint.d opnd1 opnd2) (emit-fop.d "int" #x01 opnd1 opnd2))
(define (emit-fsinh.d opnd1 opnd2) (emit-fop.d "sinh" #x02 opnd1 opnd2))
(define (emit-fintrz.d opnd1 opnd2) (emit-fop.d "intrz" #x03 opnd1 opnd2))
(define (emit-fsqrt.d opnd1 opnd2) (emit-fop.d "sqrt" #x04 opnd1 opnd2))
(define (emit-flognp1.d opnd1 opnd2) (emit-fop.d "lognp1" #x06 opnd1 opnd2))
(define (emit-fetoxm1.d opnd1 opnd2) (emit-fop.d "etoxm1" #x08 opnd1 opnd2))
(define (emit-ftanh.d opnd1 opnd2) (emit-fop.d "tanh" #x09 opnd1 opnd2))
(define (emit-fatan.d opnd1 opnd2) (emit-fop.d "atan" #x0A opnd1 opnd2))
(define (emit-fasin.d opnd1 opnd2) (emit-fop.d "asin" #x0C opnd1 opnd2))
(define (emit-fatanh.d opnd1 opnd2) (emit-fop.d "atanh" #x0D opnd1 opnd2))
(define (emit-fsin.d opnd1 opnd2) (emit-fop.d "sin" #x0E opnd1 opnd2))
(define (emit-ftan.d opnd1 opnd2) (emit-fop.d "tan" #x0F opnd1 opnd2))
(define (emit-fetox.d opnd1 opnd2) (emit-fop.d "etox" #x10 opnd1 opnd2))
(define (emit-ftwotox.d opnd1 opnd2) (emit-fop.d "twotox" #x11 opnd1 opnd2))
(define (emit-ftentox.d opnd1 opnd2) (emit-fop.d "tentox" #x12 opnd1 opnd2))
(define (emit-flogn.d opnd1 opnd2) (emit-fop.d "logn" #x14 opnd1 opnd2))
(define (emit-flog10.d opnd1 opnd2) (emit-fop.d "log10" #x15 opnd1 opnd2))
(define (emit-flog2.d opnd1 opnd2) (emit-fop.d "log2" #x16 opnd1 opnd2))
(define (emit-fabs.d opnd1 opnd2) (emit-fop.d "abs" #x18 opnd1 opnd2))
(define (emit-fcosh.d opnd1 opnd2) (emit-fop.d "cosh" #x19 opnd1 opnd2))
(define (emit-fneg.d opnd1 opnd2) (emit-fop.d "neg" #x1A opnd1 opnd2))
(define (emit-facos.d opnd1 opnd2) (emit-fop.d "acos" #x1C opnd1 opnd2))
(define (emit-fcos.d opnd1 opnd2) (emit-fop.d "cos" #x1D opnd1 opnd2))
(define (emit-fgetexp.d opnd1 opnd2) (emit-fop.d "getexp" #x1E opnd1 opnd2))
(define (emit-fgetman.d opnd1 opnd2) (emit-fop.d "getman" #x1F opnd1 opnd2))
(define (emit-fdiv.d opnd1 opnd2) (emit-fop.d "div" #x20 opnd1 opnd2))
(define (emit-fmod.d opnd1 opnd2) (emit-fop.d "mod" #x21 opnd1 opnd2))
(define (emit-fadd.d opnd1 opnd2) (emit-fop.d "add" #x22 opnd1 opnd2))
(define (emit-fmul.d opnd1 opnd2) (emit-fop.d "mul" #x23 opnd1 opnd2))
(define (emit-fsgldiv.d opnd1 opnd2) (emit-fop.d "sgldiv" #x24 opnd1 opnd2))
(define (emit-frem.d opnd1 opnd2) (emit-fop.d "rem" #x25 opnd1 opnd2))
(define (emit-fscale.d opnd1 opnd2) (emit-fop.d "scale" #x26 opnd1 opnd2))
(define (emit-fsglmul.d opnd1 opnd2) (emit-fop.d "sglmul" #x27 opnd1 opnd2))
(define (emit-fsub.d opnd1 opnd2) (emit-fop.d "sub" #x28 opnd1 opnd2))
(define (emit-fcmp.d opnd1 opnd2) (emit-fop.d "cmp" #x38 opnd1 opnd2))
(define (emit-fop.x name code opnd1 opnd2)
(asm-M68881-proc)
(asm-word (+ #xf200 (opnd->mode/reg opnd1)))
(asm-word (+ (* (if (freg? opnd1) (freg-num opnd1) #x12) 1024)
(* (freg-num opnd2) 128)
code))
(opnd-ext-rd-long opnd1)
(if ofile-asm?
(emit-asm "f" name "x" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))
(define (emit-fop.d name code opnd1 opnd2)
(asm-M68881-proc)
(asm-word (+ #xf200 (opnd->mode/reg opnd1)))
(asm-word (+ #x5400 (* (freg-num opnd2) 128) code))
(opnd-ext-rd-long opnd1)
(if ofile-asm?
(emit-asm "f" name "d" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))
(define (emit-fmov.d opnd1 opnd2)
(emit-fmov #x5400 opnd1 opnd2)
(if ofile-asm?
(emit-asm "fmoved" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))
(define (emit-fmov.l opnd1 opnd2)
(emit-fmov #x4000 opnd1 opnd2)
(if ofile-asm?
(emit-asm "fmovel" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))
(define (emit-fmov code opnd1 opnd2)
(define (fmov code opnd1 opnd2)
(asm-M68881-proc)
(asm-word (+ #xf200 (opnd->mode/reg opnd1)))
(asm-word (+ (* (freg-num opnd2) 128) code))
(opnd-ext-rd-long opnd1))
(if (freg? opnd2)
(fmov code opnd1 opnd2)
(fmov (+ code #x2000) opnd2 opnd1)))
(define (emit-ftest.d opnd1)
(asm-M68881-proc)
(asm-word (+ #xf200 (opnd->mode/reg opnd1)))
(asm-word #x543a)
(opnd-ext-rd-long opnd1)
(if ofile-asm?
(emit-asm "ftestd" ofile-tab (opnd-str opnd1))))
(define (emit-fbeq lbl)
(asm-M68881-proc)
(asm-word #xf281)
(asm-wrel lbl 0)
(if ofile-asm?
(emit-asm "fbeq" ofile-tab "L" lbl)))
(define (emit-fbne lbl)
(asm-M68881-proc)
(asm-word #xf28e)
(asm-wrel lbl 0)
(if ofile-asm?
(emit-asm "fbne" ofile-tab "L" lbl)))
(define (emit-fblt lbl)
(asm-M68881-proc)
(asm-word #xf294)
(asm-wrel lbl 0)
(if ofile-asm?
(emit-asm "fblt" ofile-tab "L" lbl)))
(define (emit-fbgt lbl)
(asm-M68881-proc)
(asm-word #xf292)
(asm-wrel lbl 0)
(if ofile-asm?
(emit-asm "fbgt" ofile-tab "L" lbl)))
(define (emit-fble lbl)
(asm-M68881-proc)
(asm-word #xf295)
(asm-wrel lbl 0)
(if ofile-asm?
(emit-asm "fble" ofile-tab "L" lbl)))
(define (emit-fbge lbl)
(asm-M68881-proc)
(asm-word #xf293)
(asm-wrel lbl 0)
(if ofile-asm?
(emit-asm "fbge" ofile-tab "L" lbl)))
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
; Operand conversion procedures:
(define (opnd->mode/reg opnd)
(cond ((disp? opnd) (+ 32 (disp-areg opnd))) ; 101 rrr
((inx? opnd) (+ 40 (inx-areg opnd))) ; 110 rrr
((pcr? opnd) 58) ; 111 010
((imm? opnd) 60) ; 111 100
((glob? opnd) (+ 32 table-reg)) ; 101 ttt
((freg? opnd) 0)
(else opnd)))
(define (opnd->reg/mode opnd)
(let ((x (opnd->mode/reg opnd)))
(* (+ (* 8 (remainder x 8)) (quotient x 8)) 64)))
(define (opnd-ext-rd-long opnd) (opnd-extension opnd #f #f))
(define (opnd-ext-rd-word opnd) (opnd-extension opnd #f #t))
(define (opnd-ext-wr-long opnd) (opnd-extension opnd #t #f))
(define (opnd-ext-wr-word opnd) (opnd-extension opnd #t #t))
(define (opnd-extension opnd write? word?)
(cond ((disp? opnd) (asm-word (disp-offset opnd)))
((inx? opnd) (asm-word (+ (+ (* (inx-ireg opnd) #x1000) #x800)
(modulo (inx-offset opnd) #x100))))
((pcr? opnd) (asm-wrel (pcr-lbl opnd) (pcr-offset opnd)))
((imm? opnd) (if word? (asm-word (imm-val opnd)) (asm-long (imm-val opnd))))
((glob? opnd) (if write? (asm-set-glob opnd) (asm-ref-glob opnd)))))
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
; Text representation of operands:
(define (opnd-str opnd) ; SUN syntax
(cond ((dreg? opnd)
(vector-ref '#("d0" "d1" "d2" "d3" "d4" "d5" "d6" "d7")
(dreg-num opnd)))
((areg? opnd)
(vector-ref '#("a0" "a1" "a2" "a3" "a4" "a5" "a6" "sp")
(areg-num opnd)))
((ind? opnd)
(vector-ref '#("a0@" "a1@" "a2@" "a3@"
"a4@" "a5@" "a6@" "sp@")
(areg-num (ind-areg opnd))))
((pinc? opnd)
(vector-ref '#("a0@+" "a1@+" "a2@+" "a3@+"
"a4@+" "a5@+" "a6@+" "sp@+")
(areg-num (pinc-areg opnd))))
((pdec? opnd)
(vector-ref '#("a0@-" "a1@-" "a2@-" "a3@-"
"a4@-" "a5@-" "a6@-" "sp@-")
(areg-num (pdec-areg opnd))))
((disp? opnd)
(string-append (opnd-str (disp-areg opnd))
"@("
(number->string (disp-offset opnd))
")"))
((inx? opnd)
(string-append (opnd-str (inx-areg opnd))
"@("
(number->string (inx-offset opnd))
","
(opnd-str (inx-ireg opnd))
":l)"))
((pcr? opnd)
(let ((lbl (pcr-lbl opnd))
(offs (pcr-offset opnd)))
(if (= offs 0)
(string-append "L" (number->string lbl))
(string-append "L" (number->string lbl)
"+" (number->string offs)))))
((imm? opnd)
(string-append "#" (number->string (imm-val opnd))))
((glob? opnd)
(string-append "GLOB("
(symbol->string (glob-name opnd))
")"))
((freg? opnd)
(vector-ref '#("fp0" "fp1" "fp2" "fp3" "fp4" "fp5" "fp6" "fp7")
(freg-num opnd)))
((reg-list? opnd)
(let loop ((l (reg-list-regs opnd)) (result "[") (sep ""))
(if (pair? l)
(loop (cdr l) (string-append result sep (opnd-str (car l))) "/")
(string-append result "]"))))
(else
(compiler-internal-error "opnd-str, unknown 'opnd'" opnd))))
;==============================================================================
